home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / Modules / ppl-ll.em < prev    next >
Lisp/Scheme  |  1992-06-02  |  3KB  |  85 lines
  1. ; Okay here's the scam, in cmlisp all parallel operations are actually
  2. ; done in the same context, I want to use as much of the cmlisp compiler
  3. ; as possible so rather than hardwiring the context into the expression
  4. ; generated we put a binding in which can be changed at execution time
  5. ; this also removes the need for the setter functions.
  6.  
  7. (defmodule ppl-ll (standard0) ()
  8.  
  9.   (defun make-pfun-name (name)
  10.     (make-symbol (format nil "PF-~a" name)))
  11.  
  12.   (defun make-pset-name (name)
  13.     (make-symbol (format nil "PS-~a" name)))
  14.  
  15.   (setq pfun-table (make-table))
  16.   (setq psetter-table (make-table))
  17.  
  18.   (defun add-pfun (name p-name args)
  19.     ((setter table-ref) pfun-table name (cons p-name args)))
  20.  
  21.   (defun add-psetter (name p-name args)
  22.     ((setter table-ref) psetter-table name (cons p-name args)))
  23.  
  24.   (defun get-pfun (name) (table-ref pfun-table name))
  25.  
  26.   (defun get-psetter (name) (table-ref psetter-table name))
  27.     
  28.   (defmacro p-0-fn (fn name other-arg)
  29.     (let ((f-name (make-pfun-name name)))
  30.       (add-pfun name f-name ())
  31.       `(progn
  32.      (defun ,f-name ()
  33.        (,fn ,@(append `(The-Context)
  34.             (if other-arg (list other-arg) ()))))
  35.      (export ,f-name))))
  36.  
  37.   (defmacro p-1-fn (fn name other-arg)
  38.     (let ((f-name (make-pfun-name name)))
  39.       (add-pfun name f-name '(a))
  40.       `(progn 
  41.      (defun ,f-name (a)
  42.        (,fn ,@(append `(The-Context a)
  43.               (if other-arg (list other-arg) ()))))
  44.      (export ,f-name))))
  45.  
  46.   (defmacro p-2-fn (fn name other-arg)
  47.     (let ((f-name (make-pfun-name name)))
  48.       (add-pfun name f-name '(a b))
  49.       `(progn (defun ,f-name (a b)
  50.         (,fn ,@(append `(The-Context a b)
  51.                    (if other-arg (list other-arg) ()))))
  52.           (export ,f-name))))
  53.  
  54.   (defmacro p-2-set (fn name other-arg)
  55.     (let ((f-name (make-pset-name name)))
  56.       (add-psetter name f-name '(a b))
  57.       `(progn (defun ,f-name (a b)
  58.         (,fn ,@(append `(The-Context a b)
  59.                    (if other-arg (list other-arg) ()))))
  60.           (export ,f-name))))
  61.  
  62.   (defmacro p-3-fn (fn name other-arg)
  63.     (let ((f-name (make-pfun-name name)))
  64.       (add-pfun name f-name '(a b c))
  65.       `(progn (defun ,f-name (a b c)
  66.         (,fn ,@(append `(The-Context a b c)
  67.                    (if other-arg (list other-arg) ()))))
  68.           (export ,f-name))))
  69.  
  70.   (defmacro p-3-set (fn name other-arg)
  71.     (let ((f-name (make-pset-name name)))
  72.       (add-psetter name f-name '(a b c))
  73.       `(progn (defun ,f-name (a b c)
  74.         (,fn ,@(append `(The-Context a b c)
  75.                    (if other-arg (list other-arg) ()))))
  76.           (export ,f-name))))
  77.  
  78.   (export p-0-fn p-1-fn p-2-fn p-3-fn make-pfun-name add-pfun add-psetter
  79.       p-2-set p-3-set get-pfun get-psetter pfun-table psetter-table)
  80. )
  81.  
  82.  
  83.  
  84.  
  85.